home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Oh!X 2001 Spring
/
Oh!X 2001 Spring Special CD-ROM (Japan).7z
/
Oh!X 2001 Spring Special CD-ROM (Japan) (Track 1).bin
/
TCLTK
/
BLOCKUP
/
blockup.tcl
< prev
next >
Wrap
Text File
|
2000-05-07
|
17KB
|
696 lines
#
# BLOCKUP.tcl : ゲーム「ブロックアップ」
#
# Copyright (C) 2000 by Makoto Hiroi
#
# 駒を下から押し上げて、同じ色を3つ以上ならべて消すゲーム
# 色は、赤、青、黄、緑、紫、水色、オレンジ
#
# 大域変数
# board() : 積みあがった駒の色
# board_l() : ブロックの移動ライン
# color() : 色
# block() : ブロックの色
# next_block() : 次のブロック
# block_x : ブロックの先頭 x 座標
# remove_piece : 消去できる駒の座標(リスト)
# down_piece : 駒が落ちた場所の座標(リスト)
# move_count : ブロックを移動させるカウンタ
# play_flag : 0 : ゲーム終了, 1 : ゲーム中
# piece_num : 駒の種類(ゲーム中で使用する)
# clolr_num : メニューで設定する
# name,data,score : トップ10用スコア
#
# ヘルプファイルの表示
proc help {} {
global path_name
if {![winfo exist .t0]} {
toplevel .t0
wm title .t0 "BlockUp Help"
text .t0.text -yscrollcommand ".t0.scroll set"
scrollbar .t0.scroll -command ".t0.text yview"
pack .t0.scroll -side right -fill y
pack .t0.text -side left
# ファイルの読み込み
set f [open "$path_name/BLOCKUP.TXT" r]
while {![eof $f]} {
.t0.text insert end [read $f 1000]
}
close $f
.t0.text configure -state disabled
}
}
# スコアファイルリード
proc read_score_file {} {
global score_file name date score
set now_date [clock seconds]
if [file exists $score_file] {
# ファイルの読み込み
set f [open $score_file r]
foreach j {6 7 8} {
for {set i 1} {$i <= 10} {incr i} {
if {[gets $f line] < 0} {
# ダミーデータをセット
set l " \t$now_data\t0"
}
set l [split $line "\t"]
set name($j,$i) [lindex $l 0]
set date($j,$i) [lindex $l 1]
set score($j,$i) [lindex $l 2]
}
}
close $f
} else {
# ダミーデータのセット
foreach j {6 7 8} {
for {set i 1} {$i <= 10} {incr i} {
set name($j,$i) ""
set date($j,$i) $now_date
set score($j,$i) 0
}
}
}
}
# スコアファイルライト
proc write_score_file {} {
global score_file name date score
set f [open $score_file w]
foreach j {6 7 8} {
for {set i 1} {$i <= 10} {incr i} {
puts $f [format "%s\t%d\t%d" $name($j,$i) $date($j,$i) $score($j,$i)]
}
}
close $f
}
#
# トップテンウィンドウを開く
#
proc open_score_window {ranking} {
global name date score piece_num color_num play_flag
if [winfo exists .t1] {
destroy .t1
}
toplevel .t1
wm title .t1 "Top 10"
frame .t1.f0
frame .t1.f1
label .t1.f0.l0 -text "順位 名前" -anchor w
label .t1.f1.l0 -text " 記録 日付 " -anchor w
pack .t1.f0.l0 -fill x
pack .t1.f1.l0 -fill x
if {$play_flag == 0} {
set num $color_num
} else {
set num $piece_num
}
for {set i 1} {$i <= 10} {incr i} {
label .t1.f0.l$i -text [format "%4d %-20s" $i $name($num,$i)] -anchor w
label .t1.f1.l$i -text [format "%6d %8s" \
$score($num,$i) \
[clock format $date($num,$i) -format "%y/%m/%d"]]
pack .t1.f0.l$i -fill x
pack .t1.f1.l$i -fill x
}
if {$ranking > 0} {
.t1.f0.l$ranking configure -fg red
.t1.f1.l$ranking configure -fg red
}
pack .t1.f0 .t1.f1 -side left
}
# ベストテンに入るか
proc check_hi_score {now_score} {
global score piece_num
for {set i 1} {$i <= 10} {incr i} {
if {$score($piece_num,$i) < $now_score} {
# ベストテンに入ったよ
return $i
}
}
return 0
}
# スコアの更新
proc update_score {n d s o} {
global name date score piece_num
for {set i 9} {$i >= $o} {incr i -1} {
set j [expr $i + 1]
set name($piece_num,$j) $name($piece_num,$i)
set date($piece_num,$j) $date($piece_num,$i)
set score($piece_num,$j) $score($piece_num,$i)
}
set name($piece_num,$o) $n
set date($piece_num,$o) $d
set score($piece_num,$o) $s
}
# トップテンの名前入力
proc input_hi_score_name {ranking} {
global buff2
set buff2 ""
toplevel .t2
wm title .t2 "Input Your Name"
wm geometry .t2 "+[expr [winfo x .] + 120]+[expr [winfo y .] + 180]"
label .t2.l0 -text [format "おめでとう! %d 位です" $ranking]
label .t2.l1 -text "名前を入力してね"
entry .t2.e0 -textvariable buff2
focus -force .t2.e0
grab set -global .t2
bind .t2.e0 <Return> {
# 入力チェックが必要か
if {$buff2 != ""} {
destroy .t2
}
}
pack .t2.l0 .t2.l1 .t2.e0
}
# 初期化
proc init_board {} {
global board piece board_l piece_l
for {set x 0} {$x < 6} {incr x} {
for {set y 0} {$y < 8} {incr y} {
set board($x,$y) 0
.c0 itemconfigure $piece($x,$y) -fill gray60
}
}
for {set x 0} {$x < 6} {incr x} {
set board_l($x) 0
.c0 itemconfigure $piece_l($x) -fill gray60
}
}
# 駒を消せるか
proc check_remove_yoko {x y} {
global board remove_piece
set c $board($x,$y)
set i 1
set xs $x
# 左
for {set x1 [expr $x - 1]} {$x1 >= 0} {incr x1 -1} {
if {$board($x1,$y) != $c} break
set xs $x1
incr i
}
# 右
set xe $x
for {set x1 [expr $x + 1]} {$x1 < 6} {incr x1} {
if {$board($x1,$y) != $c} break
set xe $x1
incr i
}
if {$i >= 3} {
# 消去できる
while {$xs <= $xe} {
set remove_piece [concat $remove_piece $xs $y]
incr xs
}
}
}
proc check_remove_tate {x y} {
global board remove_piece
set c $board($x,$y)
set i 1
set ys $y
# 上
for {set y1 [expr $y - 1]} {$y1 >= 0} {incr y1 -1} {
if {$board($x,$y1) != $c} break
set ys $y1
incr i
}
# 下
set ye $y
for {set y1 [expr $y + 1]} {$y1 < 8} {incr y1} {
if {$board($x,$y1) != $c} break
set ye $y1
incr i
}
if {$i >= 3} {
# 消去できる
while {$ys <= $ye} {
set remove_piece [concat $remove_piece $x $ys]
incr ys
}
}
}
# 左上 <-- (x,y) --> 右下
proc check_remove_naname1 {x y} {
global board remove_piece
set c $board($x,$y)
set i 1
# 左上
set xs $x
set ys $y
set x1 [expr $x - 1]
set y1 [expr $y - 1]
while {$x1 >= 0 && $y1 >= 0} {
if {$board($x1,$y1) != $c} break
set xs $x1
set ys $y1
incr x1 -1
incr y1 -1
incr i
}
# 右下
set xe $x
set ye $y
set x1 [expr $x + 1]
set y1 [expr $y + 1]
while {$x1 < 6 && $y1 < 8} {
if {$board($x1,$y1) != $c} break
set xe $x1
set ye $y1
incr x1
incr y1
incr i
}
if {$i >= 3} {
# 消去できる
while {$xs <= $xe} {
set remove_piece [concat $remove_piece $xs $ys]
incr xs
incr ys
}
}
}
# 左下 <-- (x,y) --> 右上
proc check_remove_naname2 {x y} {
global board remove_piece
set c $board($x,$y)
set i 1
# 左下
set xs $x
set ys $y
set x1 [expr $x - 1]
set y1 [expr $y + 1]
while {$x1 >= 0 && $y1 < 8} {
if {$board($x1,$y1) != $c} break
set xs $x1
set ys $y1
incr x1 -1
incr y1
incr i
}
# 右上
set xe $x
set ye $y
set x1 [expr $x + 1]
set y1 [expr $y - 1]
while {$x1 < 6 && $y1 >= 0} {
if {$board($x1,$y1) != $c} break
set xe $x1
set ye $y1
incr x1
incr y1 -1
incr i
}
if {$i >= 3} {
# 消去できる
while {$xs <= $xe} {
set remove_piece [concat $remove_piece $xs $ys]
incr xs
incr ys -1
}
}
}
# スコアの表示
proc display_score {num count} {
global message1 now_score
# 1 -> 2 -> 4 -> 8 と連鎖するたびに得点が増える
set c [expr 1 << $count]
incr now_score [expr $c * $c * $num * $num]
set message1 [format " Score %6d" $now_score]
}
# 駒を消去する
proc delete_piece {count} {
global board remove_piece piece now_score
set len [llength $remove_piece]
set i 0
set j 0
while {$i < $len} {
set x [lindex $remove_piece $i]
incr i
set y [lindex $remove_piece $i]
incr i
if {$board($x,$y) != 0} {
set board($x,$y) 0
incr j
# タグを付ける
.c0 itemconfigure $piece($x,$y) -tags remove
}
}
# アニメーションさせる
foreach c {white gray90 gray75 gray60} {
.c0 itemconfigure remove -fill $c
update
after 150
}
# タグを取り除く
.c0 dtag remove remove
# スコアの計算
display_score $j $count
}
# 駒の交換 (x1,y1) <--- (x2,y2)
proc change_piece {x1 y1 x2 y2} {
global board piece color down_piece
set c $board($x2,$y2)
set board($x1,$y1) $c
set board($x2,$y2) 0
.c0 itemconfigure $piece($x1,$y1) -fill $color($c)
.c0 itemconfigure $piece($x2,$y2) -fill gray60
set down_piece [concat $down_piece $x1 $y1]
}
# 空いている位置に駒を移動させる
proc move_piece_down {} {
global block board down_piece
set down_piece ""
for {set x 0} {$x < 6} {incr x 1} {
# 空いている位置を探す
set ys 7
while {$ys >= 0} {
if {$board($x,$ys) == 0} break
incr ys -1
}
while {$ys > 0} {
# 駒を探す
set ye [expr $ys - 1]
while {$ye >= 0} {
if {$board($x,$ye) != 0} break
incr ye -1
}
# 駒が見つからなければループから脱出
if {$ye < 0} break
# 移動
change_piece $x $ys $x $ye
incr ys -1
}
}
}
# 駒を消すことができるか
proc check_remove_piece {} {
global board block_x remove_piece down_piece
set remove_piece ""
# 押し上げた列をチェック
for {set x 0} {$x < 2} {incr x} {
set x1 [expr $block_x + $x]
for {set y 7} {$y >= 0} {incr y -1} {
if {$board($x1,$y) == 0} break
check_remove_yoko $x1 $y
check_remove_tate $x1 $y
check_remove_naname1 $x1 $y
check_remove_naname2 $x1 $y
}
}
set count 0
while {$remove_piece != ""} {
update
after 250
# 消去できる
delete_piece $count
# ブロックを落とす
move_piece_down
# 落としたブロックのチェック
set remove_piece ""
set len [llength $down_piece]
set i 0
while {$i < $len} {
set x [lindex $down_piece $i]
incr i
set y [lindex $down_piece $i]
incr i
check_remove_yoko $x $y
check_remove_tate $x $y
check_remove_naname1 $x $y
check_remove_naname2 $x $y
}
incr count
}
}
# ブロックの移動
proc move_block_up {} {
global block block_x play_flag board piece color
if {$play_flag != 1} return
set x1 $block_x
set x2 [expr $x1 + 1]
# 上に空きがあるか
if {$board($x1,0) != 0 || $board($x2,0) != 0} return
# 二重入力禁止
set play_flag 2
# ブロックを挿入する
for {set y 1} {$y <= 7} {incr y} {
set y1 [expr $y - 1]
set board($x1,$y1) $board($x1,$y)
set board($x2,$y1) $board($x2,$y)
.c0 itemconfigure $piece($x1,$y1) -fill $color($board($x1,$y1))
.c0 itemconfigure $piece($x2,$y1) -fill $color($board($x2,$y1))
}
set board($x1,7) $block(0)
set board($x2,7) $block(1)
.c0 itemconfigure $piece($x1,7) -fill $color($board($x1,7))
.c0 itemconfigure $piece($x2,7) -fill $color($board($x2,7))
# ブロックを消去
delete_block
check_remove_piece
if [check_game_over] {
game_over
} else {
set_block_start
decide_next_block
# 入力禁止解除
set play_flag 1
}
}
proc move_block_right {} {
global block block_x play_flag
if {$play_flag != 1} return
# 右端のチェック
if {$block_x == 4} return
delete_block
# 移動
incr block_x
display_block
update
}
proc move_block_left {} {
global block_x play_flag
if {$play_flag != 1} return
# 左端のチェック
if {$block_x == 0} return
delete_block
# 移動
incr block_x -1
display_block
update
}
# ブロックの回転
proc rotation_block {} {
global block play_flag
if {$play_flag != 1} return
set temp $block(0)
set block(0) $block(1)
set block(1) $temp
display_block
update
}
# ブロックを消去する
proc delete_block {} {
global block piece_l block_x
set x $block_x
for {set i 0} {$i < 2} {incr i} {
.c0 itemconfigure $piece_l($x) -fill gray60
incr x
}
}
# ブロックを表示する
proc display_block {} {
global block block_x block_l piece_l color
set x $block_x
for {set i 0} {$i < 2} {incr i} {
.c0 itemconfigure $piece_l($x) -fill $color($block($i))
incr x
}
}
# 次のブロックを決める
proc decide_next_block {} {
global next_block next_piece color piece_num
for {set i 0} {$i < 2} {incr i} {
set c [expr int( rand() * $piece_num ) + 1]
set next_block($i) $c
.c0 itemconfigure $next_piece($i) -fill $color($c)
}
}
# ブロックを開始位置にセット
proc set_block_start {} {
global next_block block block_x
set block_x 4
for {set i 0} {$i < 2} {incr i} {
set block($i) $next_block($i)
}
display_block
}
# 手詰まりをチェック
proc check_game_over {} {
global board
for {set x1 0} {$x1 < 5} {incr x1} {
set x2 [expr $x1 + 1]
if {$board($x1,0) == 0 && $board($x2,0) == 0} {
return 0
}
}
return 1
}
# ゲーム終了
proc game_over {} {
global now_score buff2 play_flag
set ranking [check_hi_score $now_score]
if {$ranking > 0} {
input_hi_score_name $ranking
tkwait window .t2
update_score $buff2 [clock seconds] $now_score $ranking
write_score_file
open_score_window $ranking
} else {
tk_messageBox -type ok -message "得点は $now_score 点でした"
}
set play_flag 0
}
# ゲームの開始
proc start_game {} {
global now_score move_count play_flag
global piece_num color_num
if {$play_flag != 0} {
set ans [tk_messageBox -type yesno -icon question \
-message "ゲームを中断しますか?"]
if {$ans == "no"} return
set play_flag 0
}
set now_score 0
set move_count 0
set play_flag 1
set piece_num $color_num
init_board
decide_next_block
set_block_start
decide_next_block
display_block
display_score 0 0
update
}
# バインド カーソルキーにも対応
bind . 5 "rotation_block"
bind . <Down> "rotation_block"
bind . <Up> "move_block_up"
bind . <space> "move_block_up"
bind . 8 "move_block_up"
bind . 4 "move_block_left"
bind . <Left> "move_block_left"
bind . 6 "move_block_right"
bind . <Right> "move_block_right"
bind . s "start_game"
# ********** メニューの設定 **********
menu .m -type menubar
. configure -menu .m
.m add cascade -label "Games" -under 0 -menu .m.m1
.m add cascade -label "Color" -under 0 -menu .m.m2
.m add command -label "Help" -under 0 -command "help"
menu .m.m1 -tearoff no
.m.m1 add command -label "Start" -under 0 -command "start_game"
.m.m1 add command -label "HiScore" -under 0 -command "open_score_window 0"
.m.m1 add separator
.m.m1 add command -label "Exit" -under 0 -command "exit"
menu .m.m2 -tearoff no
.m.m2 add radiobutton -label "6 Colors" -variable color_num -value 6
.m.m2 add radiobutton -label "7 Colors" -variable color_num -value 7
.m.m2 add radiobutton -label "8 Colors" -variable color_num -value 8
# ********** 画面の生成 **********
option add *font "{MS ゴシック} 12"
canvas .c0 -width 320 -height 320
.c0 create rectangle 0 0 320 320 -fill darkgreen
# board 用
for {set x 0} {$x < 6} {incr x} {
set x1 [expr 32 * $x + 32]
set x2 [expr $x1 + 32]
for {set y 0} {$y < 8} {incr y} {
set y1 [expr 32 * $y]
set y2 [expr $y1 + 32]
set piece($x,$y) [.c0 create rectangle $x1 $y1 $x2 $y2 -fill gray60 -outline gray60]
}
}
# board_l 用
for {set x 0} {$x < 6} {incr x} {
set x1 [expr 32 * $x + 32]
set x2 [expr $x1 + 32]
set piece_l($x) [.c0 create rectangle $x1 264 $x2 296 -fill gray60 -outline gray60]
}
# next block 用
for {set x 0} {$x < 2} {incr x} {
set x1 [expr 32 * $x + 232]
set x2 [expr $x1 + 32]
set next_piece($x) [.c0 create rectangle $x1 264 $x2 296 -fill gray60 -outline gray60]
}
.c0 create text 264 250 -text "NEXT" -fill white
# 色の設定
set x 0
foreach c {gray60 red blue yellow green cyan purple orange seagreen} {
set color($x) $c
incr x
}
# スコア表示用
label .l0 -textvariable message1 -bg darkgreen -fg white -anchor w
pack .l0 -fill x
pack .c0
# 窓の題名
wm title . "Block Up"
wm resizable . 0 0
# 初期化
set play_flag 0
set color_num 6
set path_name [file dirname $argv0]
set score_file "$path_name/BLOCKUP.SCO"
# スコアファイルのリード
read_score_file
focus -force .
# end of file